home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
graphic
/
postogrf.zip
/
STRINGS.SRC
< prev
next >
Wrap
Text File
|
1989-06-06
|
7KB
|
185 lines
{ strings.src include file with various string handlers .
Written by Thomas B. Passin in TurboPascal 5.0}
{ 18 Oct 88 v1.0x3. ReadRaw now only reverses screen attributes
if plot4 has been defined & InGraphMode is true.
28 Sept 88 v1.0x2
22 Sept 88 v1.0x1 }
{ ------------------------ procedures ---------------------------
ReadRaw(var s:string80; prompt: string80;
default:string80;);
Procedure StripWhite(var Line:string80);
Procedure LowerCase(var Comm:Namestr);
Procedure ParseComm(var Source, Destination:string80);
}
(*{$DEFINE strtest}*)
{$IFDEF strtest}
uses CRT;
{$endif}
{$define STRINGS}
type string80 = string[80];
const CR = #13; ESC = #27; BS = #8; En = #79; SP = #32; TAB = #9;
Home = #71; LF = #10;
WhiteSpace: set of char = [#8,#9,#10,#12,' '];
Yes : set of char = ['Y','y'];
{ ---------------------------------------------------------------
ReadRaw returns the following for the input string:
KEYSTROKE RETURNS
CR for 1st char s = default (erases string on screen)
CR any other time s = string typed on screen
SPACE for 1st char s = '' (erases string on screen)
ESC anytime s = ESC (erases string on screen)
<END> moves to end of string, next input adds char to string
default = default string.
Restores cursor to starting position on exit.
}
procedure ReadRaw(var s:string80; prompt: string80;
default:string80);
var chr: char; t1, t2, t3, start, ytemp:byte; tattrib:byte;
twherex, twherey:byte;
W1, W2:word;
done: boolean;
begin s := default; done := false;
twherex := wherex; twherey := wherey;
tattrib := textattr;
w1 := WindMin; w2 := Windmax;
ytemp := hi(w1) + wherey ;
start:= lo(w1) + 1;
t1 := start+ length(prompt) + 50;
if t1 > 79 then t1 := 79;
window(start,ytemp,t1, ytemp);
write(prompt);
start:= wherex; clrEOL;
if default <> '' then write(default);
t2 := wherex; t3 := start; GoToXY(start, whereY);
repeat chr := Readkey;
case chr of
BS: if (s <> '') and (t3 <> start)
then begin s := copy(s,1,length(s)-1);
dec(t3);
GoToXY(t3, wherey); clrEOL;
{write(' '); GoToXY(t3,wherey);}
end
else begin sound(2000); delay(25); nosound; end;
ESC: begin s := ESC;
GoToXY(start,wherey); clrEOL;
done := true;
end;
#0: begin if keypressed then chr := Readkey;
case chr of
En: begin t3 := start + length(s) ;
GoToXY(t3, wherey);
end;
end; {case}
chr := #0;
end;
CR: begin if t3 = start then s := default;
done := true;
end;
else begin if (t3 = start)
then if chr = SP
then begin s := '';
clrEOL;
done := true;
end
else begin clrEOL; s := chr;
inc(t3); write(chr);
end
else begin
inc(t3); write(chr);
s := s+chr;
end;
end; {else}
end; {case}
until done ;
textattr := tattrib;
clrEOL;
window(1+lo(w1), 1+hi(w1), 1 + lo(w2), 1+hi(w2));
GoToXY(twherex, twherey);
end; {ReadRaw}
{ -----------------------------------------------------------------
StripWhite
-----------------------------------------------------------------}
Procedure StripWhite(var Line:string80);
{ Removes leading whitespace in string. Returns a null string ('')
if there is only whitespace in the string
}
Var n: integer;
begin
if Line = '' then exit ELSE
begin
n := 1;
While (Line[n] in WhiteSpace) and (n < length(Line)) do n :=n+1;
if Line[n] in WhiteSpace then Line := ''
ELSE Line := Copy(Line,n, length(Line)-n+1);
end;
end;
Procedure LowerCase(var Comm:string80);
const Uppercase:set of char = ['A'..'Z'];
var i:integer;
begin
for i := 1 to Length(Comm) do
if Comm[i] in UpperCase
then Comm[i] := chr(Ord(Comm[i]) + ord('a')-ord('A'));
end;
{ ----------------------------------------------------------------
Command string parser. ParseComm strips leading whitespace from
the source string, then puts the first word into the destination
string. The end of the word is detected by the first whitespace.
Whitespace is defined as BS,LF,tab,FF, or a space.
--------------------------------------------------------------------}
Procedure ParseComm(var Source, Destination:string80);
{
processes a string into separate words ("commands"):
Strips leading whitespace from Source string.
Removes first word- delineated by trailing whitespace-
from Source & copies it into Destination.
Destination word always starts with non-whitespace unless null.
Source is set to '' if it would have been a single space.
Sets Destination to '' if Source is a null string. }
var n: integer;
begin
if Source = '' then begin Destination := ''; exit; end ELSE
begin
StripWhite(Source);
n := 1;
Repeat n :=n+1
Until (Source[n] {is} in WhiteSpace) or (n > length(Source));
Destination := copy(Source,1,n-1);
Source := copy(Source,n,length(source)-n+1);
if source = ' ' then source := '';
end;
end;
{var comm1, comm2: string80;
begin
readln(Comm2);
while Comm2 <> '' do
begin
ParseComm(Comm2,Comm1);
WRITE(COMM1,'*');
writeln(Comm2)
end
end.}
{$ifdef strtest}
var s:string80;
begin
clrscr; textbackground(blue);
window(12,10,65,18); clrscr;
readraw(s,'key string: ', 'default');
writeln; textbackground(red); {clrscr;}
writeln(s);
end
{$endif}